module mkhis_common
  use suty
  implicit none
  character*(*),parameter::MEMFAIL="*** cannot allocate memory."
  character*(*),parameter::READFAIL="*** error during read."
  integer,parameter::MAXPATHLEN=1024
  integer::nd                     ! total number of blocks
  integer,target::ndh=4           ! number of blocks in a plane
  integer,parameter::nt=64        ! number of crystals in transaxial
  integer,target::na=20           ! number of crystals in axial
  integer,target::mgap=4          ! number of crystals in a gap
  integer,target::nx=92           !na*ndh+mgap*(ndh-1) ! number of crystals in x
  integer,target::ny=nt           ! number of crystals in y
  integer nxy
  !
  integer*8,parameter::fbs=1024*1024*1024 ! maxmum byte to read at once
  integer*8,parameter::nemax=fbs/4
  integer*4,allocatable::buf(:)
  integer nbuf
  character*(MAXPATHLEN) fin,str
  character*(MAXPATHLEN),target::fout,foutp,foutd,flist
  integer istat
  integer*8 n,ie,b1,b2,fs,ne
  integer ifile,nf,id,narg,if1
  integer flg
  integer ix1,iy1,ix2,iy2
  logical lo_found
  integer*8 nb
  integer npair,ndelay
  logical::overwrite=.false.
  logical,allocatable::isfile(:)
  logical::ignoreerr=.false.
  logical::printcmdline=.false.  
  logical::useflist=.false.

  !
  integer,parameter::IOERR_FILE_EXISTS=17 ! <<< gfortran only?

contains
  
  subroutine terminate
    call claimer("SIG_TERM GOT",-2)
  end subroutine terminate

  subroutine mkhis_init
    ndelay=0
    npair=0
    nb=0
    nf=0
    nbuf=0
    call setup_SIGTERM(loc(terminate))
    call setup_SIGCHLD(loc(terminate))
  end subroutine mkhis_init
  
  subroutine parse_cmdline
    integer ia,len
    integer,pointer::dw
    character*(MAXPATHLEN),pointer::s
    nullify(dw)
    nullify(s)

    narg=command_argument_count()  
    if(narg==0) then
       call usage
       call exit(0)
    end if
    fout=""
    foutp=""
    foutd=""
    flist=""
    nf=narg
    if1=1
    allocate(isfile(narg))
    isfile=.false.
    ia=0
    do
       ia=ia+1
       if(ia>narg) exit
       call get_command_argument(ia,str,len)
       if(len>=2.and.str(1:1)=="-") then
          select case(str(2:2))
          case("b")             
             dw=>ndh
          case("c")
             dw=>na
          case("F")
             s=>flist
          case("o")
             s=>fout
          case("p")
             s=>foutp
          case("d")
             s=>foutd
          case("y")
             dw=>ny
          case("x")
             dw=>nx
          case("g")
             dw=>mgap
          case("I")
             ignoreerr=.true.
          case("f")
             overwrite=.true.
          case("h")
             call usage
             call exit(0)
          case("i")
             if(ia<narg) then
                isfile(ia+1:)=.true.
                exit
             else
                call claimer("*** too few arguments.")
             end if
          case("L")
             printcmdline=.true.
          case("v")
             overwrite=.false.
          case default
             call claimer("*** invalid option: "//trim(str))
          end select
          if((associated(s).or.associated(dw))) then
             if(ia<narg) then
                ia=ia+1
                call get_command_argument(ia,str)
                if(associated(s)) then
                   s=str
                   nullify(s)
                else if(associated(dw)) then
                   dw=a2i(str)
                   nullify(dw)
                end if
             else
                call claimer("*** missing argument for: "//trim(str))
             end if
          end if
       else
          isfile(ia)=.true.
       end if
    end do

    if(count(isfile)==0.and.flist=="") call claimer("*** too few arguments.")
    if(fout=="".and.foutp=="".and.foutd=="") call claimer("*** please specify outfile correctly.")
    nd=ndh*2
    nx=na*ndh+mgap*(ndh-1) ! number of crystals in x
    nxy=nx*ny
    if(nd<=0.or.nx<=0.or.ny<0) call claimer("*** Invalid geometry specified.")
    if(printcmdline) then
       call get_command(str)
       write(*,"(a)") "command line: \n"//trim(str)
       call flush(6)
    end if
    write(*,*) "Histogram size = "//trim(i2a(nx))//"x"//trim(i2a(ny))&
         //", with gap length = "//trim(i2a(mgap))//" crystals" 
    call flush(6)
    if(flist/="") then
       open(unit=3,file=flist,iostat=istat)
       if(istat/=0) then
          if(.not.ignoreerr) then
             call claimer("*** cannot open flist")
          else
             useflist=.false.           
          end if
       else
          useflist=.true.
       end if
    end if
  end subroutine parse_cmdline

  integer function get_next_file(i)
    use kuty
    integer,intent(in)::i
    ifile=ifile+1
    get_next_file=0 ! cycle
    if(i<=narg) then
       if(.not.isfile(i)) return
       call get_command_argument(i,fin)
    else if(useflist) then
       read(3,"(a)",iostat=istat) fin
       if(istat/=0) then
          get_next_file=-1
          return
       end if
       if(len_trim(fin)==0) return
    else
       get_next_file=-1 ! exit
       return
    end if
    fin=trim(adjustl(fin))     
    write(*,"(x,a,x,$)") "Opening file: "//trim(fin)
    call flush(6)
    open(unit=1,file=fin,status="old",access="stream",iostat=istat)
    if(istat/=0) then
       write(0,*) "*** cannot open input file: code = "//trim(i2a(istat))
       call flush(6)
       if(ignoreerr) return
       call claimer
    end if
    nf=nf+1
    fs=fsize(fin)
    write(*,"(x,a)") "=> "//trim(i2a(fs))//" bytes"
    call flush(6)
    if(fs==0) then
       close(1)
       return
    end if
    get_next_file=1
  end function get_next_file
  
  subroutine usage
    write(*,100)
100 format(x, "Usage: mkhis [-x nx -y ny -b ndh -g mgap [-f | -v]] [-I]",/,&
         8x,"{-o outfile_true -p outfile_prompt -d outfile_delayed}",/,&
         8x,"{[-i] inputfiles... | -F filelist}",/,/,&
         8x,"Options:",/,&
         8x,"-x,-y\tDimensions of the histogram in x- and y-axis (Default = 92x64).",/,&
         8x,"-g\tNumber of crystals in a gap between blocks (Default = 4).",/,&
         8x,"-b\tNumber of blocks in a detector plane (Default = 4).",/,&
         8x,"-c\tNumber of crystals in a block (Default = 20).",/,&
         8x,"-f\tAllow overwriting of output files.",/,&
         8x,"-v\tAsk before overwriting of output files (default).",/,&
         8x,"-I\tSkip invalid input files (Default = STOP).")
  end subroutine usage
  
  subroutine print_stats(file,byte,ok,delay,&
       pair,flip,over,under,lost)
    integer,intent(in)::file,byte,ok,delay
    integer,intent(in),optional::pair,flip,over,under,lost
    write(*,*) "Number of files read:    ",file
    write(*,*) "Number of bytes read:    ",byte
    if(present(pair))&
    write(*,*) "Number of pair:          ",pair
    write(*,*) "Number of accept events: ",ok
    write(*,*) "Number of random events: ",delay    
    if(present(flip))&
    write(*,*) "Number of fliped events: ",flip
    if(present(over))&
    write(*,*) "Number of overflow:      ",over
    if(present(under))&
    write(*,*) "Number of underflow:     ",under
    if(present(lost))&
    write(*,*) "Number of lost 4-byte:   ",lost
    call flush(6)
  end subroutine print_stats

  subroutine output(nh,php0,phd0)
    integer,intent(in)::nh,php0,phd0
    integer*2 hp(*),hd(*)
    integer pc,dc
    integer j
    pointer(php,hp)
    pointer(phd,hd)
    php=php0
    phd=phd0
    pc=0
    dc=0
    do j=1,nh
       pc=hp(j)+pc
       dc=hd(j)+dc
    end do
    if(foutp/="") call write_hist(nh,hp,foutp)
    if(foutd/="") call write_hist(nh,hd,foutd)    
    write(*,*) "Max Prompt: ",maxval(hp(1:nh))
    write(*,*) "Max Delayed:",maxval(hd(1:nh))
    call flush(6)
    hp(1:nh)=hp(1:nh)-hd(1:nh)
    where(hp(1:nh)<0) hp(1:nh)=0
    write(*,*) "Max True:   ",maxval(hp(1:nh))
    write(*,*) "Prompt Count: ",pc
    write(*,*) "Delayed Count:",dc
    write(*,*) "True Count:   ",pc-dc
    call flush(6)
    if(fout/="") call write_hist(nh,hp,fout)
  end subroutine output
  
  recursive subroutine write_hist(n,h,outfile)
    integer,intent(in)::n
    integer*2,intent(in)::h(n)
    character*(*),intent(inout)::outfile
    integer istat
    character*128 s
    character*8 os
    if(overwrite) then
       os="replace"
    else
       os="new"
    end if
    write(*,"(x,a,x,$)") "Writing "//trim(outfile)//"..."
    call flush(6)
    open(unit=1,file=outfile,access="stream",status=os,iostat=istat)
    if(istat/=0) then
       write(0,*) "\n *** error during open: code = "//trim(i2a(istat))       
       call flush(0)
       if(.not.overwrite.and.istat==IOERR_FILE_EXISTS) then
          do
             write(*,"(x,a,$)") "[Quit/Overwrite/Newfile] => "
             read(*,"(a)") s
             select case(s)
             case("Q","q")
                return
             case("O","o")
                overwrite=.true.
             case("N","n")
                write(*,"(x,a,$)") "filename => "
                read(*,"(a)") outfile                
             case default
                cycle
             end select
             exit
          end do
          call write_hist(n,h,outfile)
       else
          call claimer("*** Failed to open file: check permission")
       end if
    else
       write(1,iostat=istat) h(1:n)
       close(1)
       if(istat/=0) then
          write(0,*) "*** error during write: code = "//trim(i2a(istat))
       else
          s=trim(i2a(nx))//"x"//trim(i2a(ny))
          write(*,*) "size: "//trim(s)//"x"//trim(s)//"x"//trim(i2a(sizeof(h(1))))//" = "&
               //trim(i2a(sizeof(h)))//" bytes"
       end if
       call flush(6)
    end if
  end subroutine write_hist

  subroutine claimer(msg,code)
    character*(*),intent(in),optional::msg
    integer,intent(in),optional::code
    integer rc
    if(present(msg)) write(0,"(x,a)") msg
    rc=-1
    if(present(code)) rc=code
    call exit(rc)
  end subroutine claimer
  
end module mkhis_common
